home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / classify.pso < prev    next >
Encoding:
Text File  |  1992-02-17  |  22.9 KB  |  475 lines
  1. ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
  2.  
  3. ; This file was generated by Pseudoscheme 2.8a
  4. ;  running in Lucid Common Lisp 4.0.1
  5. ;  from file /amd/night/b/jar/pseudo/classify.scm
  6.  
  7. (SCHI:BEGIN-TRANSLATED-FILE)
  8. (DEFUN CLASSIFY
  9.        (FORM ENV)
  10.        (DECLARE (SPECIAL CLASS/LITERAL
  11.                          CLASS/APPLICATION
  12.                          CLASS/NAME))
  13.        (IF (SCHI:TRUEP (NAME? FORM))
  14.            (.VALUES CLASS/NAME FORM ENV)
  15.            (IF (CONSP FORM)
  16.                (IF (SCHI:TRUEP (NAME? (CAR FORM)))
  17.                    (LET ((DEN (LOOKUP ENV (CAR FORM))))
  18.                      (IF (SCHI:TRUEP (SPECIAL-OPERATOR? DEN))
  19.                          (LET ((CLASS (SPECIAL-OPERATOR-CLASS DEN)))
  20.                            (IF (SCHI:TRUEP
  21.                                  (CHECK-SPECIAL-FORM-SYNTAX CLASS FORM))
  22.                                (.VALUES CLASS FORM ENV)
  23.                                (CLASSIFY
  24.                                  (SYNTAX-ERROR "invalid special form syntax"
  25.                                                FORM)
  26.                                  ENV)))
  27.                          (IF (SCHI:TRUEP (MACRO? DEN))
  28.                              (CLASSIFY-MACRO-APPLICATION DEN FORM ENV)
  29.                              (.VALUES CLASS/APPLICATION FORM ENV))))
  30.                    (.VALUES CLASS/APPLICATION FORM ENV))
  31.                (IF (SCHI:TRUEP (LITERAL? FORM))
  32.                    (.VALUES CLASS/LITERAL FORM ENV)
  33.                    (CLASSIFY (SYNTAX-ERROR "unknown expression type"
  34.                                            FORM)
  35.                              ENV)))))
  36. (SCHI:SET-VALUE-FROM-FUNCTION 'CLASSIFY
  37.                               'SCHEME::CLASSIFY)
  38. (DEFUN CLASSIFY-MACRO-APPLICATION
  39.        (DEN FORM USE-ENV)
  40.        (LET ((DEF-ENV (MACRO-ENVIRONMENT DEN)))
  41.          (WITH-VALUES #'(LAMBDA NIL
  42.                                 (MAKE-RENAMER+ENV DEF-ENV USE-ENV))
  43.                       #'(LAMBDA (RENAME OUTPUT-ENV)
  44.                          (FLET
  45.                           ((COMPARE (CLIENT-NAME MACRO-NAME)
  46.                             (IF
  47.                              (AND (SCHI:TRUEP (NAME? CLIENT-NAME))
  48.                               (SCHI:TRUEP (NAME? MACRO-NAME)))
  49.                              (SAME-DENOTATION?
  50.                               (LOOKUP OUTPUT-ENV CLIENT-NAME)
  51.                               (LOOKUP OUTPUT-ENV MACRO-NAME))
  52.                              (SCHI:TRUE? (EQ CLIENT-NAME MACRO-NAME)))))
  53.                           (LET
  54.                            ((NEW-FORM
  55.                              (FUNCALL (MACRO-TRANSFORMER DEN) FORM RENAME
  56.                               #'COMPARE)))
  57.                            (CLASSIFY NEW-FORM OUTPUT-ENV)))))))
  58. (SCHI:SET-VALUE-FROM-FUNCTION 'CLASSIFY-MACRO-APPLICATION
  59.                               'SCHEME::CLASSIFY-MACRO-APPLICATION)
  60. (DEFUN PROCESS-SYNTAX-SPEC
  61.        (SSPEC ENV)
  62.        (MAKE-MACRO (EVAL-FOR-SYNTAX SSPEC
  63.                                     (GET-ENVIRONMENT-FOR-SYNTAX ENV))
  64.                    ENV))
  65. (SCHI:SET-VALUE-FROM-FUNCTION 'PROCESS-SYNTAX-SPEC
  66.                               'SCHEME::PROCESS-SYNTAX-SPEC)
  67. (DEFUN PROCESS-DEFINE-SYNTAX
  68.        (FORM ENV)
  69.        (DEFINE! ENV
  70.                 (CADR FORM)
  71.                 (PROCESS-SYNTAX-SPEC (CADDR FORM) ENV)))
  72. (SCHI:SET-VALUE-FROM-FUNCTION 'PROCESS-DEFINE-SYNTAX
  73.                               'SCHEME::PROCESS-DEFINE-SYNTAX)
  74. (DEFUN CLASSIFY-LET-SYNTAX
  75.        (FORM ENV)
  76.        (DECLARE (SPECIAL SYNTAX-SPEC-NAME))
  77.        (LET ((DSPECS (LET-SYNTAX-FORM-DSPECS FORM)))
  78.          (CLASSIFY (LET-SYNTAX-FORM-BODY FORM)
  79.                    (BIND (MAPCAR SYNTAX-SPEC-NAME DSPECS)
  80.                          (MAPCAR
  81.                            #'(LAMBDA (DSPEC)
  82.                               (PROCESS-SYNTAX-SPEC (SYNTAX-SPEC-FORM DSPEC) ENV))
  83.                            DSPECS)
  84.                          ENV))))
  85. (SCHI:SET-VALUE-FROM-FUNCTION 'CLASSIFY-LET-SYNTAX
  86.                               'SCHEME::CLASSIFY-LET-SYNTAX)
  87. (DEFUN CLASSIFY-LETREC-SYNTAX
  88.        (FORM OUTER-ENV)
  89.        (LET ((NEW (NEW-ENVIRONMENT OUTER-ENV)))
  90.          (MAPC
  91.            #'(LAMBDA (DSPEC)
  92.               (DEFINE! NEW (SYNTAX-SPEC-NAME DSPEC)
  93.                (PROCESS-SYNTAX-SPEC (SYNTAX-SPEC-FORM DSPEC) NEW)))
  94.            (LETREC-SYNTAX-FORM-DSPECS FORM))
  95.          (CLASSIFY (LETREC-SYNTAX-FORM-BODY FORM)
  96.                    NEW)))
  97. (SCHI:SET-VALUE-FROM-FUNCTION 'CLASSIFY-LETREC-SYNTAX
  98.                               'SCHEME::CLASSIFY-LETREC-SYNTAX)
  99. (DEFUN LOOKUP
  100.        (ENV NAME)
  101.        (IF (SCHI:TRUEP (LOCAL-ENVIRONMENT? ENV))
  102.            (LET ((PROBE
  103.                    (SCHI:TRUE?
  104.                      (ASSOC NAME
  105.                             (LOCAL-ENVIRONMENT-BINDINGS ENV)
  106.                             :TEST
  107.                             #'EQ))))
  108.              (IF (SCHI:TRUEP PROBE)
  109.                  (CDR PROBE)
  110.                  (LOOKUP (LOCAL-ENVIRONMENT-PARENT ENV)
  111.                          NAME)))
  112.            (IF (SCHI:TRUEP (DIVERTED-ENVIRONMENT? ENV))
  113.                (IF (AND (SCHI:TRUEP (GENERATED? NAME))
  114.                         (SCHI:TRUEP
  115.                           (SAME-GENERATION? (GENERATED-GENERATION NAME)
  116.                                             (DIVERTED-ENVIRONMENT-GENERATION
  117.                                               ENV))))
  118.                    (LOOKUP (DIVERTED-ENVIRONMENT-MACRO-ENV ENV)
  119.                            (GENERATED-NAME NAME))
  120.                    (LOOKUP (DIVERTED-ENVIRONMENT-PARENT ENV)
  121.                            NAME))
  122.                (CLIENT-LOOKUP ENV NAME))))
  123. (SCHI:SET-VALUE-FROM-FUNCTION 'LOOKUP 'SCHEME::LOOKUP)
  124. (DEFUN DEFINE!
  125.        (ENV NAME DENOTATION)
  126.        (IF (SCHI:TRUEP (LOCAL-ENVIRONMENT? ENV))
  127.            (LET ((BS (LOCAL-ENVIRONMENT-BINDINGS ENV)))
  128.              (LET ((PROBE (SCHI:TRUE? (ASSOC NAME BS :TEST #'EQ))))
  129.                (IF (SCHI:TRUEP PROBE)
  130.                    (PROGN (SETF (CDR PROBE) DENOTATION)
  131.                           SCHI:UNSPECIFIED)
  132.                    (SET-LOCAL-ENVIRONMENT-BINDINGS! ENV
  133.                                                     (CONS
  134.                                                       (CONS NAME DENOTATION)
  135.                                                       BS)))))
  136.            (IF (SCHI:TRUEP (DIVERTED-ENVIRONMENT? ENV))
  137.                (DEFINE! (DIVERTED-ENVIRONMENT-PARENT ENV)
  138.                         NAME
  139.                         DENOTATION)
  140.                (CLIENT-DEFINE! ENV NAME DENOTATION))))
  141. (SCHI:SET-VALUE-FROM-FUNCTION 'DEFINE! 'SCHEME::DEFINE!)
  142. (LOCALLY (DECLARE (SPECIAL LOCAL-ENVIRONMENT-RTD))
  143.          (SETQ LOCAL-ENVIRONMENT-RTD (MAKE-RECORD-TYPE
  144.                                        'SCHEME::LOCAL-ENVIRONMENT
  145.                                        '(SCHEME::PARENT SCHEME::BINDINGS))))
  146. (SCHI:SET-FUNCTION-FROM-VALUE 'LOCAL-ENVIRONMENT-RTD
  147.                               'SCHEME::LOCAL-ENVIRONMENT-RTD)
  148. (LOCALLY (DECLARE (SPECIAL MAKE-LOCAL-ENVIRONMENT
  149.                            LOCAL-ENVIRONMENT-RTD))
  150.          (SETQ MAKE-LOCAL-ENVIRONMENT (RECORD-CONSTRUCTOR LOCAL-ENVIRONMENT-RTD
  151.                                                           '(SCHEME::PARENT
  152.                                                             SCHEME::BINDINGS)))
  153.                )
  154. (SCHI:SET-FUNCTION-FROM-VALUE 'MAKE-LOCAL-ENVIRONMENT
  155.                               'SCHEME::MAKE-LOCAL-ENVIRONMENT)
  156. (LOCALLY (DECLARE (SPECIAL LOCAL-ENVIRONMENT?
  157.                            LOCAL-ENVIRONMENT-RTD))
  158.          (SETQ LOCAL-ENVIRONMENT? (RECORD-PREDICATE LOCAL-ENVIRONMENT-RTD)))
  159. (SCHI:SET-FUNCTION-FROM-VALUE 'LOCAL-ENVIRONMENT?
  160.                               'SCHEME::LOCAL-ENVIRONMENT?)
  161. (LOCALLY (DECLARE (SPECIAL LOCAL-ENVIRONMENT-PARENT
  162.                            LOCAL-ENVIRONMENT-RTD))
  163.          (SETQ LOCAL-ENVIRONMENT-PARENT (RECORD-ACCESSOR LOCAL-ENVIRONMENT-RTD
  164.                                                          'SCHEME::PARENT)))
  165. (SCHI:SET-FUNCTION-FROM-VALUE 'LOCAL-ENVIRONMENT-PARENT
  166.                               'SCHEME::LOCAL-ENVIRONMENT-PARENT)
  167. (LOCALLY (DECLARE (SPECIAL LOCAL-ENVIRONMENT-BINDINGS
  168.                            LOCAL-ENVIRONMENT-RTD))
  169.          (SETQ LOCAL-ENVIRONMENT-BINDINGS (RECORD-ACCESSOR
  170.                                             LOCAL-ENVIRONMENT-RTD
  171.                                             'SCHEME::BINDINGS)))
  172. (SCHI:SET-FUNCTION-FROM-VALUE 'LOCAL-ENVIRONMENT-BINDINGS
  173.                               'SCHEME::LOCAL-ENVIRONMENT-BINDINGS)
  174. (LOCALLY
  175.   (DECLARE (SPECIAL SET-LOCAL-ENVIRONMENT-BINDINGS!
  176.                     LOCAL-ENVIRONMENT-RTD))
  177.   (SETQ SET-LOCAL-ENVIRONMENT-BINDINGS! (RECORD-MODIFIER LOCAL-ENVIRONMENT-RTD
  178.                                                          'SCHEME::BINDINGS)))
  179. (SCHI:SET-FUNCTION-FROM-VALUE 'SET-LOCAL-ENVIRONMENT-BINDINGS!
  180.                               'SCHEME::SET-LOCAL-ENVIRONMENT-BINDINGS!)
  181. (LOCALLY (DECLARE (SPECIAL DIVERTED-ENVIRONMENT-RTD))
  182.          (SETQ DIVERTED-ENVIRONMENT-RTD (MAKE-RECORD-TYPE
  183.                                           'SCHEME::DIVERTED-ENVIRONMENT
  184.                                           '(SCHEME::PARENT SCHEME::GENERATION
  185.                                             SCHEME::MACRO-ENV))))
  186. (SCHI:SET-FUNCTION-FROM-VALUE 'DIVERTED-ENVIRONMENT-RTD
  187.                               'SCHEME::DIVERTED-ENVIRONMENT-RTD)
  188. (LOCALLY (DECLARE (SPECIAL MAKE-DIVERTED-ENVIRONMENT
  189.                            DIVERTED-ENVIRONMENT-RTD))
  190.          (SETQ MAKE-DIVERTED-ENVIRONMENT (RECORD-CONSTRUCTOR
  191.                                            DIVERTED-ENVIRONMENT-RTD
  192.                                            '(SCHEME::GENERATION
  193.                                              SCHEME::MACRO-ENV SCHEME::PARENT)))
  194.                )
  195. (SCHI:SET-FUNCTION-FROM-VALUE 'MAKE-DIVERTED-ENVIRONMENT
  196.                               'SCHEME::MAKE-DIVERTED-ENVIRONMENT)
  197. (LOCALLY (DECLARE (SPECIAL DIVERTED-ENVIRONMENT?
  198.                            DIVERTED-ENVIRONMENT-RTD))
  199.          (SETQ DIVERTED-ENVIRONMENT? (RECORD-PREDICATE DIVERTED-ENVIRONMENT-RTD))
  200.                )
  201. (SCHI:SET-FUNCTION-FROM-VALUE 'DIVERTED-ENVIRONMENT?
  202.                               'SCHEME::DIVERTED-ENVIRONMENT?)
  203. (LOCALLY
  204.   (DECLARE (SPECIAL DIVERTED-ENVIRONMENT-PARENT
  205.                     DIVERTED-ENVIRONMENT-RTD))
  206.   (SETQ DIVERTED-ENVIRONMENT-PARENT (RECORD-ACCESSOR DIVERTED-ENVIRONMENT-RTD
  207.                                                      'SCHEME::PARENT)))
  208. (SCHI:SET-FUNCTION-FROM-VALUE 'DIVERTED-ENVIRONMENT-PARENT
  209.                               'SCHEME::DIVERTED-ENVIRONMENT-PARENT)
  210. (LOCALLY
  211.   (DECLARE (SPECIAL DIVERTED-ENVIRONMENT-GENERATION
  212.                     DIVERTED-ENVIRONMENT-RTD))
  213.   (SETQ DIVERTED-ENVIRONMENT-GENERATION (RECORD-ACCESSOR
  214.                                           DIVERTED-ENVIRONMENT-RTD
  215.                                           'SCHEME::GENERATION)))
  216. (SCHI:SET-FUNCTION-FROM-VALUE 'DIVERTED-ENVIRONMENT-GENERATION
  217.                               'SCHEME::DIVERTED-ENVIRONMENT-GENERATION)
  218. (LOCALLY
  219.   (DECLARE (SPECIAL DIVERTED-ENVIRONMENT-MACRO-ENV
  220.                     DIVERTED-ENVIRONMENT-RTD))
  221.   (SETQ DIVERTED-ENVIRONMENT-MACRO-ENV (RECORD-ACCESSOR
  222.                                          DIVERTED-ENVIRONMENT-RTD
  223.                                          'SCHEME::MACRO-ENV)))
  224. (SCHI:SET-FUNCTION-FROM-VALUE 'DIVERTED-ENVIRONMENT-MACRO-ENV
  225.                               'SCHEME::DIVERTED-ENVIRONMENT-MACRO-ENV)
  226. (DEFUN BIND
  227.        (NAMES DENOTATIONS OUTER-ENV)
  228.        (MAKE-LOCAL-ENVIRONMENT OUTER-ENV
  229.                                (MAPCAR #'CONS NAMES DENOTATIONS)))
  230. (SCHI:SET-VALUE-FROM-FUNCTION 'BIND 'SCHEME::BIND)
  231. (DEFUN NEW-ENVIRONMENT
  232.        (OUTER-ENV)
  233.        (MAKE-LOCAL-ENVIRONMENT OUTER-ENV 'NIL))
  234. (SCHI:SET-VALUE-FROM-FUNCTION 'NEW-ENVIRONMENT
  235.                               'SCHEME::NEW-ENVIRONMENT)
  236. (DEFUN FOR-EACH-LOCAL
  237.        (PROC ENV)
  238.        (FLET
  239.          ((DOIT (NAME+DEN)
  240.                 (LET ((DEN (CDR NAME+DEN)))
  241.                   (IF (AND (NOT (SCHI:TRUEP (MACRO? DEN)))
  242.                            (NOT (SCHI:TRUEP (SPECIAL-OPERATOR? DEN))))
  243.                       (FUNCALL PROC DEN)))))
  244.          (PROG (ENV@0)
  245.                (SETQ ENV@0 ENV)
  246.                (GO .LOOP)
  247.            .LOOP (IF (SCHI:TRUEP (LOCAL-ENVIRONMENT? ENV@0))
  248.                      (PROGN (MAPC #'DOIT
  249.                                   (LOCAL-ENVIRONMENT-BINDINGS ENV@0))
  250.                             (SETQ ENV@0 (LOCAL-ENVIRONMENT-PARENT ENV@0))
  251.                             (GO .LOOP))
  252.                      (IF (SCHI:TRUEP (DIVERTED-ENVIRONMENT? ENV@0))
  253.                          (PROGN
  254.                            (SETQ ENV@0 (DIVERTED-ENVIRONMENT-PARENT ENV@0))
  255.                            (GO .LOOP))
  256.                          (RETURN SCHI:UNSPECIFIED))))))
  257. (SCHI:SET-VALUE-FROM-FUNCTION 'FOR-EACH-LOCAL
  258.                               'SCHEME::FOR-EACH-LOCAL)
  259. (LOCALLY (DECLARE (SPECIAL SAME-DENOTATION? EQ?))
  260.          (SETQ SAME-DENOTATION? EQ?))
  261. (SCHI:SET-FUNCTION-FROM-VALUE 'SAME-DENOTATION?
  262.                               'SCHEME::SAME-DENOTATION?)
  263. (LOCALLY (DECLARE (SPECIAL TYPE/SPECIAL-OPERATOR))
  264.          (SETQ TYPE/SPECIAL-OPERATOR (MAKE-RECORD-TYPE "Special operator"
  265.                                                        '(SCHEME::CLASS))))
  266. (SCHI:SET-FUNCTION-FROM-VALUE 'TYPE/SPECIAL-OPERATOR
  267.                               'SCHEME::TYPE/SPECIAL-OPERATOR)
  268. (LOCALLY (DECLARE (SPECIAL MAKE-SPECIAL-OPERATOR
  269.                            TYPE/SPECIAL-OPERATOR))
  270.          (SETQ MAKE-SPECIAL-OPERATOR (RECORD-CONSTRUCTOR TYPE/SPECIAL-OPERATOR
  271.                                                          '(SCHEME::CLASS))))
  272. (SCHI:SET-FUNCTION-FROM-VALUE 'MAKE-SPECIAL-OPERATOR
  273.                               'SCHEME::MAKE-SPECIAL-OPERATOR)
  274. (LOCALLY (DECLARE (SPECIAL SPECIAL-OPERATOR?
  275.                            TYPE/SPECIAL-OPERATOR))
  276.          (SETQ SPECIAL-OPERATOR? (RECORD-PREDICATE TYPE/SPECIAL-OPERATOR)))
  277. (SCHI:SET-FUNCTION-FROM-VALUE 'SPECIAL-OPERATOR?
  278.                               'SCHEME::SPECIAL-OPERATOR?)
  279. (LOCALLY (DECLARE (SPECIAL SPECIAL-OPERATOR-CLASS
  280.                            TYPE/SPECIAL-OPERATOR))
  281.          (SETQ SPECIAL-OPERATOR-CLASS (RECORD-ACCESSOR TYPE/SPECIAL-OPERATOR
  282.                                                        'SCHEME::CLASS)))
  283. (SCHI:SET-FUNCTION-FROM-VALUE 'SPECIAL-OPERATOR-CLASS
  284.                               'SCHEME::SPECIAL-OPERATOR-CLASS)
  285. (LOCALLY (DECLARE (SPECIAL TYPE/MACRO))
  286.          (SETQ TYPE/MACRO (MAKE-RECORD-TYPE "Macro"
  287.                                             '(SCHEME::PROC SCHEME::ENV))))
  288. (SCHI:SET-FUNCTION-FROM-VALUE 'TYPE/MACRO
  289.                               'SCHEME::TYPE/MACRO)
  290. (LOCALLY (DECLARE (SPECIAL MAKE-MACRO TYPE/MACRO))
  291.          (SETQ MAKE-MACRO (RECORD-CONSTRUCTOR TYPE/MACRO
  292.                                               '(SCHEME::PROC SCHEME::ENV))))
  293. (SCHI:SET-FUNCTION-FROM-VALUE 'MAKE-MACRO
  294.                               'SCHEME::MAKE-MACRO)
  295. (LOCALLY (DECLARE (SPECIAL MACRO? TYPE/MACRO))
  296.          (SETQ MACRO? (RECORD-PREDICATE TYPE/MACRO)))
  297. (SCHI:SET-FUNCTION-FROM-VALUE 'MACRO? 'SCHEME::MACRO?)
  298. (LOCALLY (DECLARE (SPECIAL MACRO-TRANSFORMER
  299.                            TYPE/MACRO))
  300.          (SETQ MACRO-TRANSFORMER (RECORD-ACCESSOR TYPE/MACRO
  301.                                                   'SCHEME::PROC)))
  302. (SCHI:SET-FUNCTION-FROM-VALUE 'MACRO-TRANSFORMER
  303.                               'SCHEME::MACRO-TRANSFORMER)
  304. (LOCALLY (DECLARE (SPECIAL MACRO-ENVIRONMENT
  305.                            TYPE/MACRO))
  306.          (SETQ MACRO-ENVIRONMENT (RECORD-ACCESSOR TYPE/MACRO
  307.                                                   'SCHEME::ENV)))
  308. (SCHI:SET-FUNCTION-FROM-VALUE 'MACRO-ENVIRONMENT
  309.                               'SCHEME::MACRO-ENVIRONMENT)
  310. (DEFUN NAME?
  311.        (THING)
  312.        (OR (SCHI:SCHEME-SYMBOL-P THING)
  313.            (GENERATED? THING)))
  314. (SCHI:SET-VALUE-FROM-FUNCTION 'NAME? 'SCHEME::NAME?)
  315. (LOCALLY (DECLARE (SPECIAL SAME-NAME? EQ?))
  316.          (SETQ SAME-NAME? EQ?))
  317. (SCHI:SET-FUNCTION-FROM-VALUE 'SAME-NAME?
  318.                               'SCHEME::SAME-NAME?)
  319. (LOCALLY (DECLARE (SPECIAL NAME-MEMBER MEMQ))
  320.          (SETQ NAME-MEMBER MEMQ))
  321. (SCHI:SET-FUNCTION-FROM-VALUE 'NAME-MEMBER
  322.                               'SCHEME::NAME-MEMBER)
  323. (LOCALLY (DECLARE (SPECIAL NAME-ASSOC ASSQ))
  324.          (SETQ NAME-ASSOC ASSQ))
  325. (SCHI:SET-FUNCTION-FROM-VALUE 'NAME-ASSOC
  326.                               'SCHEME::NAME-ASSOC)
  327. (DEFUN NAME->SYMBOL
  328.        (NAME)
  329.        (IF (SCHI:SCHEME-SYMBOL-P NAME)
  330.            NAME
  331.            (VALUES (INTERN (NAME->STRING NAME)
  332.                            SCHI:SCHEME-PACKAGE))))
  333. (SCHI:SET-VALUE-FROM-FUNCTION 'NAME->SYMBOL
  334.                               'SCHEME::NAME->SYMBOL)
  335. (DEFUN NAME->STRING
  336.        (NAME)
  337.        (IF (SCHI:SCHEME-SYMBOL-P NAME)
  338.            (SYMBOL->STRING NAME)
  339.            (STRING-APPEND "."
  340.                           (NAME->STRING (GENERATED-NAME NAME))
  341.                           "."
  342.                           (NUMBER->STRING (GENERATED-GENERATION NAME)))))
  343. (SCHI:SET-VALUE-FROM-FUNCTION 'NAME->STRING
  344.                               'SCHEME::NAME->STRING)
  345. (LOCALLY (DECLARE (SPECIAL TYPE/GENERATED))
  346.          (SETQ TYPE/GENERATED (MAKE-RECORD-TYPE "Generated"
  347.                                                 '(SCHEME::NAME
  348.                                                   SCHEME::GENERATION))))
  349. (SCHI:SET-FUNCTION-FROM-VALUE 'TYPE/GENERATED
  350.                               'SCHEME::TYPE/GENERATED)
  351. (LOCALLY (DECLARE (SPECIAL MAKE-GENERATED
  352.                            TYPE/GENERATED))
  353.          (SETQ MAKE-GENERATED (RECORD-CONSTRUCTOR TYPE/GENERATED
  354.                                                   '(SCHEME::NAME
  355.                                                     SCHEME::GENERATION))))
  356. (SCHI:SET-FUNCTION-FROM-VALUE 'MAKE-GENERATED
  357.                               'SCHEME::MAKE-GENERATED)
  358. (LOCALLY (DECLARE (SPECIAL GENERATED? TYPE/GENERATED))
  359.          (SETQ GENERATED? (RECORD-PREDICATE TYPE/GENERATED)))
  360. (SCHI:SET-FUNCTION-FROM-VALUE 'GENERATED?
  361.                               'SCHEME::GENERATED?)
  362. (LOCALLY (DECLARE (SPECIAL GENERATED-NAME
  363.                            TYPE/GENERATED))
  364.          (SETQ GENERATED-NAME (RECORD-ACCESSOR TYPE/GENERATED
  365.                                                'SCHEME::NAME)))
  366. (SCHI:SET-FUNCTION-FROM-VALUE 'GENERATED-NAME
  367.                               'SCHEME::GENERATED-NAME)
  368. (LOCALLY (DECLARE (SPECIAL GENERATED-GENERATION
  369.                            TYPE/GENERATED))
  370.          (SETQ GENERATED-GENERATION (RECORD-ACCESSOR TYPE/GENERATED
  371.                                                      'SCHEME::GENERATION)))
  372. (SCHI:SET-FUNCTION-FROM-VALUE 'GENERATED-GENERATION
  373.                               'SCHEME::GENERATED-GENERATION)
  374. (DEFUN STRIP
  375.        (THING)
  376.        (IF (SCHI:TRUEP (GENERATED? THING))
  377.            (STRIP (GENERATED-NAME THING))
  378.            (IF (CONSP THING)
  379.                (LET ((X (STRIP (CAR THING)))
  380.                      (Y (STRIP (CDR THING))))
  381.                  (IF (AND (EQ X (CAR THING))
  382.                           (EQ Y (CDR THING)))
  383.                      THING
  384.                      (CONS X Y)))
  385.                (IF (SCHI:TRUEP (VECTOR? THING))
  386.                    (LET ((NEW (MAKE-VECTOR (LENGTH (THE SIMPLE-VECTOR
  387.                                                         THING)))))
  388.                      (PROG (I@0 SAME?@1)
  389.                            (PSETQ I@0 0 SAME?@1 SCHI:TRUE)
  390.                            (GO .LOOP)
  391.                        .LOOP (LET ((I I@0)
  392.                                    (SAME? SAME?@1))
  393.                                (IF (>= I
  394.                                        (LENGTH (THE SIMPLE-VECTOR THING)))
  395.                                    (IF (SCHI:TRUEP SAME?)
  396.                                        (RETURN THING)
  397.                                        (RETURN NEW))
  398.                                    (LET ((X (STRIP (SVREF THING I))))
  399.                                      (SETF (SVREF NEW I) X)
  400.                                      SCHI:UNSPECIFIED
  401.                                      (PSETQ I@0
  402.                                             (+ I 1)
  403.                                             SAME?@1
  404.                                             (IF (SCHI:TRUEP SAME?)
  405.                                                 (SCHI:TRUE?
  406.                                                   (EQ X
  407.                                                       (SVREF THING I)))
  408.                                                 SCHI:FALSE))
  409.                                      (GO .LOOP))))))
  410.                    THING))))
  411. (SCHI:SET-VALUE-FROM-FUNCTION 'STRIP 'SCHEME::STRIP)
  412. (LOCALLY (DECLARE (SPECIAL *GENERATION*))
  413.          (SETQ *GENERATION* 1))
  414. (SCHI:SET-FORWARDING-FUNCTION '*GENERATION*
  415.                               'SCHEME::*GENERATION*)
  416. (DEFUN NEW-GENERATION
  417.        NIL
  418.        (DECLARE (SPECIAL *GENERATION*))
  419.        (SETQ *GENERATION* (+ *GENERATION* 1))
  420.        *GENERATION*)
  421. (SCHI:SET-VALUE-FROM-FUNCTION 'NEW-GENERATION
  422.                               'SCHEME::NEW-GENERATION)
  423. (LOCALLY (DECLARE (SPECIAL SAME-GENERATION? .=))
  424.          (SETQ SAME-GENERATION? .=))
  425. (SCHI:SET-FUNCTION-FROM-VALUE 'SAME-GENERATION?
  426.                               'SCHEME::SAME-GENERATION?)
  427. (DEFUN MAKE-RENAMER+ENV
  428.        (MACRO-ENV CLIENT-ENV)
  429.        (LET ((ALIST 'NIL)
  430.              (GENERATION (NEW-GENERATION)))
  431.          (.VALUES
  432.            #'(LAMBDA (NAME)
  433.               (LET ((PROBE (SCHI:TRUE? (ASSOC NAME ALIST :TEST #'EQ))))
  434.                (IF (SCHI:TRUEP PROBE) (CDR PROBE)
  435.                 (LET ((NEW-NAME (MAKE-GENERATED NAME GENERATION)))
  436.                  (SETQ ALIST (CONS (CONS NAME NEW-NAME) ALIST)) NEW-NAME))))
  437.            (MAKE-DIVERTED-ENVIRONMENT GENERATION MACRO-ENV CLIENT-ENV))))
  438. (SCHI:SET-VALUE-FROM-FUNCTION 'MAKE-RENAMER+ENV
  439.                               'SCHEME::MAKE-RENAMER+ENV)
  440. (DEFUN SCAN-BODY
  441.        (FORMS ENV)
  442.        (DECLARE (SPECIAL CLASS/BEGIN
  443.                          DUMMY-FOR-DEFINE
  444.                          CLASS/DEFINE))
  445.        (LET ((ENV@0 (NEW-ENVIRONMENT ENV)))
  446.          (LABELS
  447.            ((.LOOP (FORMS@1 SPECS)
  448.                    (WITH-VALUES #'(LAMBDA NIL
  449.                                           (CLASSIFY (CAR FORMS@1)
  450.                                                     ENV@0))
  451.                                 #'(LAMBDA (CLASS FORM ENV@2)
  452.                                    (IF (= CLASS CLASS/DEFINE)
  453.                                     (PROGN
  454.                                      (DEFINE! ENV@2 (DEFINE-FORM-LHS FORM)
  455.                                       DUMMY-FOR-DEFINE)
  456.                                      (.LOOP (CDR FORMS@1)
  457.                                       (CONS
  458.                                        (LIST (DEFINE-FORM-LHS FORM)
  459.                                         (DEFINE-FORM-RHS FORM) ENV@2)
  460.                                        SPECS)))
  461.                                     (IF (= CLASS CLASS/BEGIN)
  462.                                      (.LOOP
  463.                                       (APPEND (BEGIN-FORM-STATEMENTS FORM)
  464.                                        (CDR FORMS@1))
  465.                                       SPECS)
  466.                                      (.VALUES (REVERSE SPECS) FORMS@1 ENV@2)))))))
  467.            (.LOOP FORMS 'NIL))))
  468. (SCHI:SET-VALUE-FROM-FUNCTION 'SCAN-BODY
  469.                               'SCHEME::SCAN-BODY)
  470. (LOCALLY (DECLARE (SPECIAL DUMMY-FOR-DEFINE))
  471.          (SETQ DUMMY-FOR-DEFINE (MAKE-GENERATED 'SCHEME::UNDEFINED
  472.                                                 0)))
  473. (SCHI:SET-FUNCTION-FROM-VALUE 'DUMMY-FOR-DEFINE
  474.                               'SCHEME::DUMMY-FOR-DEFINE)
  475.